home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / aminet / util / gnu / emacs_src_18_58.lha / emacs-18.58 / lisp / hanoi.el < prev    next >
Lisp/Scheme  |  1992-02-21  |  5KB  |  193 lines
  1. ;
  2. ; hanoi - towers of hanoi in GNUmacs
  3. ;
  4. ; Author (a) 1985, Damon Anton Permezel
  5. ;
  6.  
  7. ;;;
  8. ;;; hanoi-topos - direct cursor addressing
  9. ;;;
  10. (defun hanoi-topos (row col)
  11.   (goto-line row)
  12.   (beginning-of-line)
  13.   (forward-char col))
  14.  
  15. ;;;
  16. ;;; hanoi - user callable Towers of Hanoi
  17. ;;;
  18. (defun hanoi (nrings)
  19.   "Towers of Hanoi diversion.  Argument is number of rings."
  20.   (interactive
  21.    (list (if (null current-prefix-arg)
  22.          3
  23.          (prefix-numeric-value current-prefix-arg))))  
  24.   (if (<= nrings 0) (error "Negative number of rings"))
  25.   (let (pole-spacing
  26.     floor-row
  27.     fly-row
  28.     (window-height (window-height (selected-window)))
  29.     (window-width (window-width (selected-window))))
  30.     (let ((h (+ nrings 2))
  31.       (w (+ (* (1- nrings) 6) 2 5)))
  32.       (if (not (and (>= window-width h)
  33.             (> window-width w)))
  34.       (progn
  35.         (delete-other-windows)
  36.         (if (not (and (>= (setq window-height
  37.                     (window-height (selected-window))) h)
  38.               (> (setq window-width
  39.                    (window-width (selected-window))) w)))
  40.         (error "Screen is too small (need at least %dx%d)" w h))))
  41.       (setq pole-spacing (/ window-width 6))
  42.       (if (not (zerop (logand pole-spacing 1)))
  43.       ;; must be even
  44.       (setq pole-spacing (1+ pole-spacing)))
  45.       (setq floor-row (if (> (- window-height 3) h)
  46.               (- window-height 3) window-height)))
  47.     (let ((fly-row (- floor-row nrings 1))
  48.       ;; pole: column . fill height
  49.       (pole-1 (cons pole-spacing floor-row))
  50.       (pole-2 (cons (* 3 pole-spacing) floor-row))
  51.       (pole-3 (cons (* 5 pole-spacing) floor-row))
  52.       (rings (make-vector nrings nil)))
  53.       ;; construct the ring list
  54.       (let ((i 0))
  55.     (while (< i nrings)
  56.       ;; ring: [pole-number string empty-string]
  57.       (aset rings i (vector nil
  58.                 (make-string (+ i i 3) (+ ?0 i))
  59.                 (make-string (+ i i 3) ?\  )))
  60.       (setq i (1+ i))))
  61.       ;;
  62.       ;; init the screen
  63.       ;;
  64.       (switch-to-buffer "*Hanoi*")
  65.       (setq buffer-read-only nil)
  66.       (buffer-flush-undo (current-buffer))
  67.       (erase-buffer)
  68.       (let ((i 0))
  69.     (while (< i floor-row)
  70.       (setq i (1+ i))
  71.       (insert-char ?\  (1- window-width))
  72.       (insert ?\n)))
  73.       (insert-char ?= (1- window-width))
  74.  
  75.       (let ((n 1))
  76.     (while (< n 6)
  77.       (hanoi-topos fly-row (* n pole-spacing))
  78.       (setq n (+ n 2))
  79.       (let ((i fly-row))
  80.         (while (< i floor-row)
  81.           (setq i (1+ i))
  82.           (next-line 1)
  83.           (insert ?\|)
  84.           (delete-char 1)
  85.           (backward-char 1)))))
  86.       ;(sit-for 0)
  87.       ;;
  88.       ;; now draw the rings in their initial positions
  89.       ;;
  90.       (let ((i 0)
  91.         ring)
  92.     (while (< i nrings)
  93.       (setq ring (aref rings (- nrings 1 i)))
  94.       (aset ring 0 (- floor-row i))
  95.       (hanoi-topos (cdr pole-1)
  96.                (- (car pole-1) (- nrings i)))
  97.       (hanoi-draw-ring ring t nil)
  98.       (setcdr pole-1 (1- (cdr pole-1)))
  99.       (setq i (1+ i))))
  100.       (setq buffer-read-only t)
  101.       (sit-for 0)
  102.       ;;
  103.       ;; do it!
  104.       ;;
  105.       (hanoi0 (1- nrings) pole-1 pole-2 pole-3)
  106.       (goto-char (point-min))
  107.       (message "Done")
  108.       (setq buffer-read-only t)
  109.       (set-buffer-modified-p (buffer-modified-p))
  110.       (sit-for 0))))
  111.  
  112. ;;;
  113. ;;; hanoi0 - work horse of hanoi
  114. ;;;
  115. (defun hanoi0 (n from to work)
  116.   (cond ((input-pending-p)
  117.      (signal 'quit (list "I can tell you've had enough")))
  118.     ((< n 0))
  119.     (t
  120.      (hanoi0 (1- n) from work to)
  121.      (hanoi-move-ring n from to)
  122.      (hanoi0 (1- n) work to from))))
  123.  
  124. ;;;
  125. ;;; hanoi-move-ring - move ring 'n' from 'from' to 'to'
  126. ;;;
  127. ;;;
  128. (defun hanoi-move-ring (n from to)
  129.   (let ((ring (aref rings n))        ; ring <- ring: (ring# . row)
  130.     (buffer-read-only nil))
  131.     (let ((row (aref ring 0))        ; row <- row ring is on
  132.       (col (- (car from) n 1))    ; col <- left edge of ring
  133.       (dst-col (- (car to) n 1))    ; dst-col <- dest col for left edge
  134.       (dst-row (cdr to)))        ; dst-row <- dest row for ring
  135.       (hanoi-topos row col)
  136.       (while (> row fly-row)        ; move up to the fly row
  137.     (hanoi-draw-ring ring nil t)    ; blank out ring
  138.     (previous-line 1)        ; move up a line
  139.     (hanoi-draw-ring ring t nil)    ; redraw
  140.     (sit-for 0)
  141.     (setq row (1- row)))
  142.       (setcdr from (1+ (cdr from)))    ; adjust top row
  143.       ;;
  144.       ;; fly the ring over to the right pole
  145.       ;;
  146.       (while (not (equal dst-col col))
  147.     (cond ((> dst-col col)        ; dst-col > col: right shift
  148.            (end-of-line 1)
  149.            (delete-backward-char 2)
  150.            (beginning-of-line 1)
  151.            (insert ?\  ?\  )
  152.            (sit-for 0)
  153.            (setq col (1+ (1+ col))))
  154.           ((< dst-col col)        ; dst-col < col: left shift
  155.            (beginning-of-line 1)
  156.            (delete-char 2)
  157.            (end-of-line 1)
  158.            (insert ?\  ?\  )
  159.            (sit-for 0)
  160.            (setq col (1- (1- col))))))
  161.       ;;
  162.       ;; let the ring float down
  163.       ;;
  164.       (hanoi-topos fly-row dst-col)
  165.       (while (< row dst-row)        ; move down to the dest row
  166.     (hanoi-draw-ring ring nil (> row fly-row)) ; blank out ring
  167.     (next-line 1)            ; move down a line
  168.     (hanoi-draw-ring ring t nil)    ; redraw ring
  169.     (sit-for 0)
  170.     (setq row (1+ row)))
  171.       (aset ring 0 dst-row)
  172.       (setcdr to (1- (cdr to))))))    ; adjust top row
  173.  
  174. ;;;
  175. ;;; draw-ring -    draw the ring at point, leave point unchanged
  176. ;;;
  177. ;;; Input:
  178. ;;;    ring
  179. ;;;    f1    -    flag: t -> draw, nil -> erase
  180. ;;;    f2    -    flag: t -> erasing and need to draw ?\|
  181. ;;;
  182. (defun hanoi-draw-ring (ring f1 f2)
  183.   (save-excursion
  184.     (let* ((string (if f1 (aref ring 1) (aref ring 2)))
  185.        (len (length string)))
  186.       (delete-char len)
  187.       (insert string)
  188.       (if f2
  189.       (progn
  190.         (backward-char (/ (+ len 1) 2))
  191.         (delete-char 1) (insert ?\|))))))
  192.  
  193.